Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/demo/3ddemomr/ctl3d.bas

BASIC Source File | 1995-03-26 | 16.2 KB | 460 lines

Option Explicit

'Compiled by:  M. John Rodriguez,  CIS ID: 100321,620
'                             Internet ID: [e-mail]
'                                        : [e-mail]
'
'Please feel free to distribute this for your use and experiments.  Please ensure
'that you give credit to the folks who unknowingly helped to do this.
'
'
'This procedures contained in this module are the culmination of work supplied by various
'individuals.  It would not be proper for me not to include their names.  To make it easier
'to tell who authored what, their names are commented in the appropriate procedures.
'
'
'CTL3D API calls... If you don't have CTL3DV2.DLL, you can delete the V2 and it should
'still work properly.
Declare Function Ctl3dAutoSubclass Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dRegister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dUnregister Lib "Ctl3DV2.DLL" (ByVal hInst As Integer) As Integer
Declare Function Ctl3dSubclassDlgEx Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer, ByVal dFlags As Long) As Integer
Declare Function Ctl3dSubclassCtlEx Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer, ByVal cFlags As Integer) As Integer
Declare Function Ctl3dUnsubclassCtl Lib "Ctl3DV2.DLL" (ByVal hWnd As Integer) As Integer
Declare Function Ctl3DGetVer Lib "Ctl3DV2.DLL" () As Integer


'Other API Calls for the Forms...
Declare Function GetModuleHandle Lib "Kernel" (ByVal ModuleName As String) As Integer
Declare Function GetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Long
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
Declare Function SetWindowLong Lib "User" (ByVal hWnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long

Global Const FIXED_DOUBLE = 3
Global Const DS_MODALFRAME = &H80&
Global Const GWL_STYLE = (-16)
Global Const GWW_HINSTANCE = (-6)
Global Const CTL3D_ALL = &HFFFF

'Menu API's for adjusting the 3D Dialog box system menu...
Declare Function GetSystemMenu% Lib "User" (ByVal hWnd%, ByVal bRevert%)
Declare Function RemoveMenu% Lib "User" (ByVal hMenu%, ByVal nPosition%, ByVal wFlags%)
Global Const MF_BYPOSITION = &H400

'Some colors for us to use...
Global Const COLOR_BLACK = &H0&
Global Const COLOR_LIGHT_GRAY = &HC0C0C0
Global Const COLOR_DARK_GRAY = &H808080
Global Const COLOR_WHITE = &HFFFFFF

'/* Ctl3d Control ID */
Global Const CTL3D_BUTTON_CTL = 0
Global Const CTL3D_LISTBOX_CTL = 1
Global Const CTL3D_EDIT_CTL = 2
Global Const CTL3D_COMBO_CTL = 3
Global Const CTL3D_STATIC_CTL = 4

'Global Variables to allow for SubClassing Ctrls in our form...
Global gSubClassCtls As Integer
Global gCTL3DMajorVersion As Integer
Global gCTL3DMinorVersion As Integer



'This procedure does a couple of things.
'First, it will attempt to register your application to the CTL3D Program.
'Second, it will attempt to tell you if the system can register 3D Controls
'Only CTL3D Version 2.63 or greater can be used to make VB controls appear 3D
'
'
Function App3DRegister () As Integer

Dim appInst%, suc%

'Really just needed if we can get the CTL3D or CTL3DV2 dll's
On Error GoTo AppRegError

'Do version checking.  This will also let us know if we can't get the dll's
suc% = Ctl3DGetVer()

'If we get a version number then pass check it for control subclass capability
If suc% > 0 Then
    gCTL3DMajorVersion = (suc% And 65100) \ (2 ^ 8)
    gCTL3DMinorVersion = suc% And 255
    If (gCTL3DMajorVersion > 1) And (gCTL3DMinorVersion > 12) Then gSubClassCtls = True
End If

'Get the application instance...
appInst% = GetModuleHandle(App.EXEName)
'Now register the application
suc% = Ctl3dRegister(appInst%)
'Did it register?
If suc% = 0 Then Exit Function

'Now subclass all of the dialog and message boxes for 3D, should work with VB
suc% = Ctl3dAutoSubclass(appInst%)
'We had not problems so tell the app we registered with CTL3D
App3DRegister = True

'In case an error occurred
AppRegError:

End Function

'Before you exit your application, give this procedure a call..
'In this case, I have a procedure called ExitProgram() that allows
'me to do all of my cleanup functions.  This procedure is in there.
'
Sub App3DUnregister ()

'Call this just before your application exits..

Dim appInst%, suc%

'Get the application instance again..
appInst% = GetModuleHandle(App.EXEName)

'Now unregister us...
suc% = Ctl3dUnregister(appInst%)

End Sub

'
' ControlIn3D paints a 3D-border around the control given in ctrlTarget.
' nBevel controls the the deepness, nSpace the distance between the control
' and the 3D-border and bInset sets the border to be drawn inset or outset.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
'
Sub ComboBoxIn3D (ctrlCombo As Control, nBevel As Integer)

    Dim PixelX As Integer, PixelY As Integer
    Dim CTop As Integer, CRight As Integer, CBottom As Integer

    ' Just put "No 3D" in the Tag property and your ComboBox keeps 2D
    If InStr(UCase(ctrlCombo.Tag), "NO 3D") = 0 Then

    ControlIn3D ctrlCombo, nBevel, 0, True

    If ctrlCombo.Style = 0 Then             'Remove white space only
        PixelX = Screen.TwipsPerPixelX      'if it is a Dropdown ComboBox
        PixelY = Screen.TwipsPerPixelY
        CTop = ctrlCombo.Top
        CRight = ctrlCombo.Left + ctrlCombo.Width
        CBottom = ctrlCombo.Top + ctrlCombo.Height
        ctrlCombo.Parent.Line (CRight - PixelX * 24, CTop)-(CRight - PixelX * 18, CBottom - PixelY), COLOR_LIGHT_GRAY, BF
    End If
    End If

End Sub

'
'
' ControlIn3D paints a 3D-border around the control given in ctrlTarget.
' nBevel controls the the deepness, nSpace the distance between the control
' and the 3D-border and bInset sets the border to be drawn inset or outset.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
Sub ControlIn3D (ctrlTarget As Control, nBevel As Integer, nSpace As Integer, bInset As Integer)
    Dim CTop As Integer, CLeft As Integer, CRight As Integer, CBottom As Integer
    Dim PixelX As Integer, PixelY As Integer, AddX As Integer, AddY As Integer
    Dim i As Integer

    ' Just put "No 3D" in the Tag property and your control keeps 2D
    If InStr(UCase(ctrlTarget.Tag), "NO 3D") = 0 Then
    PixelX = Screen.TwipsPerPixelX
    PixelY = Screen.TwipsPerPixelY
    CTop = ctrlTarget.Top - PixelY
    CLeft = ctrlTarget.Left - PixelX
    CRight = ctrlTarget.Left + ctrlTarget.Width
    CBottom = ctrlTarget.Top + ctrlTarget.Height
    If bInset Then          ' Draw border inset
        For i = nSpace To (nBevel + nSpace - 1)
        AddX = i * PixelX: AddY = i * PixelY
        ctrlTarget.Parent.Line (CLeft - AddX, CTop - AddY)-(CRight + AddX, CTop - AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CLeft - AddX, CTop - AddY)-(CLeft - AddX, CBottom + AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CLeft - AddX, CBottom + AddY)-(CRight + AddX + PixelX, CBottom + AddY), COLOR_WHITE
        ctrlTarget.Parent.Line (CRight + AddX, CTop - AddY)-(CRight + AddX, CBottom + AddY), COLOR_WHITE
        Next i
    Else                    ' Draw border outset
        For i = nSpace To (nBevel + nSpace - 1)
        AddX = i * PixelX: AddY = i * PixelY
        ctrlTarget.Parent.Line (CRight + AddX, CBottom + AddY)-(CRight + AddX, CTop - AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CRight + AddX, CBottom + AddY)-(CLeft - AddX, CBottom + AddY), COLOR_DARK_GRAY
        ctrlTarget.Parent.Line (CRight + AddX, CTop - AddY)-(CLeft - AddX - PixelX, CTop - AddY), COLOR_WHITE
        ctrlTarget.Parent.Line (CLeft - AddX, CBottom + AddY)-(CLeft - AddX, CTop - AddY), COLOR_WHITE
        Next i
    End If
    End If

End Sub

'This procedure modifies the menu for the dialog box.
'In order for this to work correctly, the form must have the MinButton and MaxButton set
'to false if you leave the ControlBox property set to true.  Otherwise, Restore, Maximize, and
'Minimize will stay on...
'
'This snippet of code was taken by a submission from
'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
'
'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
'
'The author did not say if he did this, I am passing the accolades - with a few
'modifications for readability
'
Sub DlgSysMenu (fm As Form)

Dim hSysMenu%, suc%

' Obtain the handle to the forms System menu
hSysMenu% = GetSystemMenu(fm.hWnd, False)

' Remove all but the MOVE and CLOSE options.  The menu items
' must be removed starting with the last menu item.
'
suc% = RemoveMenu(hSysMenu, 8, MF_BYPOSITION) 'Switch to
suc% = RemoveMenu(hSysMenu, 7, MF_BYPOSITION) 'Separator
suc% = RemoveMenu(hSysMenu, 5, MF_BYPOSITION) 'Separator


End Sub

'
' FormIn3D paints a 3D-border around controls on the given Form frmTarget.
' nBevel controls the the deepness of the 3D-border.
'
' Controls that are affected:
'       TextBox         ListBox         ComboBox
'       DriveListBox    DirListBox      FileListBox
'       Line
'       ... (list can be easly expanded)
'
' Just put "No 3D" in the Tag property of a specific control or the form
' itself and it is not painted in 3D.
'
' Call this function from your forms Paint-event.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
' Modifications from original source:  bBlaster was removed because it wasn't
' necessary for this file.
'
Sub FormIn3D (frmTarget As Form, nBevel As Integer)
    Dim DrawWidthOld As Integer, ScaleModeOld As Integer
    Dim i As Integer, Ret As Integer
    Dim ctrlTarget As Control
    Static bBusy As Integer


    If bBusy Then Exit Sub          'Got some DoEvents. Just in case...
    bBusy = True

    DrawWidthOld = frmTarget.DrawWidth
    frmTarget.DrawWidth = 1
    ScaleModeOld = frmTarget.ScaleMode
    frmTarget.ScaleMode = 1     'Twips

    DoEvents

    'Loop controls
    For i = 0 To (frmTarget.Controls.Count - 1)
    Set ctrlTarget = frmTarget.Controls(i)
    If TypeOf ctrlTarget Is TextBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is ListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is ComboBox Then   'ComboBoxes are special
    ComboBoxIn3D ctrlTarget, nBevel
    End If
    If TypeOf ctrlTarget Is DriveListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is DirListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is FileListBox Then ControlIn3D ctrlTarget, nBevel, 0, True
    If TypeOf ctrlTarget Is Line Then       'Lines are also special
    LineIn3D ctrlTarget
    End If
    If TypeOf ctrlTarget Is Label Then ControlIn3D ctrlTarget, nBevel, 0, True
    Next i

    frmTarget.DrawWidth = DrawWidthOld      'Always restore what you change
    frmTarget.ScaleMode = ScaleModeOld

    bBusy = False

End Sub

'This procedure makes my dialog box appear 3D.
'
'This snippet of code was taken by a submission from
'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
'
'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
'
'This procedure was not commented, I am just telling you where I got the source
'for this because it works very well...
'
'This procedure modifies the menu for the dialog box.
' This procedure makes the VB form appear as a dialog box for CTL3D to read
' and paint it...
''
'This snippet of code was taken by a submission from
'RANDRIAMBOLOLONA Roland H. - Compuserve ID - 100331,2516
'
'He says he got some of it from the MARCH '95 VBPJ  Code Listing - TIPS.TXT
'
'The author did not say if he did this, I am passing the accolades - with a few
'modifications for readability
'
Sub FormToDialog (frm As Form)

    Dim hWnd As Integer
    Dim iResult As Integer
    Dim lStyle As Long

    hWnd = frm.hWnd
    If frm.BorderStyle = FIXED_DOUBLE Then
    frm.BackColor = COLOR_LIGHT_GRAY
    lStyle = GetWindowLong(hWnd, GWL_STYLE)
    lStyle = lStyle Or DS_MODALFRAME
    lStyle = SetWindowLong(hWnd, GWL_STYLE, lStyle)
    iResult = Ctl3dSubclassDlgEx(hWnd, &H0)
    End If

End Sub

'
' LineIn3D paints the given Line-control ctrlLine in 3D.
' frmTarget is the Form containing that Line.
'
' Parts of this code are taken from the VB Tips & Tricks help file.
' Original code written by Matej Nastran.
'
Sub LineIn3D (ctrlLine As Control)

    If InStr(UCase(ctrlLine.Tag), "NO 3D") = 0 Then
    ctrlLine.BorderColor = COLOR_DARK_GRAY
    'Check if line is vertical or horizontal
    If Abs(ctrlLine.X2 - ctrlLine.X1) > Abs(ctrlLine.Y2 - ctrlLine.Y1) Then
    ctrlLine.Parent.Line (ctrlLine.X1, ctrlLine.Y1 + Screen.TwipsPerPixelY)-(ctrlLine.X2, ctrlLine.Y2 + Screen.TwipsPerPixelY), COLOR_WHITE
    Else
    ctrlLine.Parent.Line (ctrlLine.X1 + Screen.TwipsPerPixelX, ctrlLine.Y1)-(ctrlLine.X2 + Screen.TwipsPerPixelX, ctrlLine.Y2), COLOR_WHITE
    End If
    End If

End Sub

'Make3DDlg
'Call this procedure in a forms Form_Load event to register the form
'as a 3D Dialog.  This procedure calls the appropriate subprocedures
'in making the Dialog 3D
'
Sub Make3DDlg (dlgfrm As Form)

'Set the dlg forms attributes for CTL3D to paint it..
FormToDialog dlgfrm

'Now make the system menu for the form to show only Move and Close.
'NOTE:  You must set the MinButton and MaxButton properties to False.
'The ControlBox property being set to False will have no effect on
'this procedure.
DlgSysMenu dlgfrm

'Turn all of the controls 3D. If you have the wrong version, MakeDlgCtrls will not
'register the controls because the API call isn't there.
'If the CTL3D is too old, then place the following code in each dialogs Form_Paint event
'   FormIn3D Me, 1
'
If gSubClassCtls Then MakeDlgCtrls3D dlgfrm

End Sub

' This procedure cycles through the controls in the form and then
' attempts to subclass them for 3D effects.  Because the controls in VB
' are all class Thunder, CTL3D can't see them as they are so we force
' it to say "Hey, Paint me 3D!"
'
' You can add other controls to this list as long as they match the
' specification on them.
'
'
'
'
Sub MakeDlgCtrls3D (dlgfrm As Form)

Dim i As Integer
Dim ctrl As Control

If Not gSubClassCtls Then Exit Sub

For i = 0 To (dlgfrm.Controls.Count - 1)
    Set ctrl = dlgfrm.Controls(i)
    If TypeOf ctrl Is TextBox Then Reg3DCtrl ctrl, CTL3D_EDIT_CTL
    If TypeOf ctrl Is ListBox Then Reg3DCtrl ctrl, CTL3D_LISTBOX_CTL
    If TypeOf ctrl Is ComboBox Then Reg3DCtrl ctrl, CTL3D_COMBO_CTL
    If TypeOf ctrl Is DriveListBox Then Reg3DCtrl ctrl, CTL3D_COMBO_CTL
    If TypeOf ctrl Is DirListBox Then Reg3DCtrl ctrl, CTL3D_LISTBOX_CTL
    If TypeOf ctrl Is FileListBox Then Reg3DCtrl ctrl, CTL3D_LISTBOX_CTL
    If TypeOf ctrl Is CheckBox Then Reg3DCtrl ctrl, CTL3D_BUTTON_CTL
    If TypeOf ctrl Is OptionButton Then Reg3DCtrl ctrl, CTL3D_BUTTON_CTL
Next i

dlgfrm.Refresh

End Sub

'  Used to register a control for 3D by CTL3D.  Does not have to be
'  a dialog form to have it painted 3D
'
'
Sub Reg3DCtrl (ctrl As Control, ctrltype As Integer)

Dim suc%

suc% = Ctl3dSubclassCtlEx(ctrl.hWnd, ctrltype)

End Sub

'  This unregisters controls from the dialog or whatever form.  Use this
'  as a cleanup method so as not to corrupt CTL3D or waste resources.
'  Called from the Form_Unload procedure
'
Sub Undo3DCtrls (frm As Form)

Dim i As Integer
Dim ctrl As Control


If Not gSubClassCtls Then Exit Sub

For i = 0 To (frm.Controls.Count - 1)
    Set ctrl = frm.Controls(i)
    If TypeOf ctrl Is TextBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is ListBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is ComboBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is DriveListBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is DirListBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is FileListBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is CheckBox Then UnReg3DCtrl ctrl
    If TypeOf ctrl Is OptionButton Then UnReg3DCtrl ctrl
Next i


End Sub

'  Call this procedure to unregister your controls
'  If you call the Reg3DCtrl procedure, call this one
'  in the Form_Unload event for the form.
'
'
Sub UnReg3DCtrl (ctrl As Control)

Dim suc%

suc% = Ctl3dUnsubclassCtl(ctrl.hWnd)


End Sub